home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DATETIME.SWG / 0029_Julian Dates.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-02  |  9KB  |  343 lines
  1. {
  2. VINCE LAURENT
  3.  
  4. > Does anyone have a fast function for sorting two dates?
  5. > Something like function SortDate(Date1, Date2 : string): integer;
  6. > Strings would be in the format of '1/1/94' etc.
  7.  
  8. Convert the dates to Julian Dates first...then you can do with them
  9. what you want.  Here is a unit I got a long time ago...
  10. }
  11.  
  12. UNIT Julian;
  13. {
  14. ////////////////////////////////////////// DEMO Routines
  15. /Begin
  16. /  ClrScr;
  17. /  GetDate(Year,Month,Day,Dow);
  18.  
  19. /  WriteLn('Year  : ',Year);
  20. /  WriteLn('Month : ',Month);
  21. /  WriteLn('Day   : ',Day);
  22. /  WriteLn('DOW   : ',Dow);
  23. /  WriteLn(MachineDate);
  24. /  JulianDate := DateToJulian(MachineDate);
  25. /  WriteLn('Julian Date = ',JulianDate);
  26. /  WriteLn('Jul To Date = ',JulianToDate(JulianDate));
  27. /  WriteLn('Day Of Week = ',DayOfWeek(JulianDate));
  28. /  WriteLn('Time        = ',MachineTime(4));
  29. /End.
  30. ///////////////////////////////////////////////////////////////
  31. }
  32. INTERFACE
  33.  
  34. Uses
  35.   Crt, Dos;
  36.  
  37. Type
  38.   Str3  = String[3];
  39.   Str8  = String[8];
  40.   Str9  = String[9];
  41.   Str11 = String[11];
  42.  
  43. Var
  44.   Hour,
  45.   Minute,
  46.   Second,
  47.   S100,
  48.   Year,
  49.   Month,
  50.   Day,
  51.   Dow        : Word;
  52.   Syear,
  53.   Smonth,
  54.   Sday,
  55.   Sdow       : String;
  56.   JulianDate : Integer;
  57.  
  58. Function  MachineTime(Len : Byte) : Str11;
  59. Function  MachineDate : Str8;
  60. Function  DateFactor(MonthNum, DayNum, YearNum : Real) : Real;
  61. Function  DateToJulian(DateLine : Str8) : Integer;
  62. Function  JulianToDate(DateInt : Integer): Str11;
  63. Function  JulianToStr8(DateInt : Integer): Str8;
  64. Function  DayofWeek(Jdate : Integer) : Str3;
  65. Procedure DateDiff(Date1,Date2 : Integer; VAR Date_Difference : Str9);
  66.  
  67. IMPLEMENTATION
  68.  
  69. Function MachineTime(Len : Byte) : Str11;
  70. Var
  71.   I       : Byte;
  72.   TempStr : String;
  73.   TimeStr : Array[1..4] Of String;
  74.  
  75. Begin
  76.   TempStr := '';
  77.   FillChar(TimeStr, SizeOf(TimeStr),0);
  78.   GetTime(Hour, Minute, Second, S100);
  79.   Str(Hour, TimeStr[1]);
  80.   Str(Minute, TimeStr[2]);
  81.   Str(Second, TimeStr[3]);
  82.   Str(S100, TimeStr[4]);
  83.   TempStr := TimeStr[1];
  84.   For I := 2 To Len Do
  85.     TempStr := TempStr + ':' + TimeStr[I];
  86.   MachineTime := TempStr;
  87. End;
  88.  
  89. Function MachineDate : Str8;
  90. Begin
  91.   GetDate(Year, Month, Day, Dow);
  92.   Str(Year, Syear);
  93.   Str(Month, Smonth);
  94.   If Month < 10 Then
  95.     Smonth := '0' + Smonth;
  96.   Str(Day,Sday);
  97.   If Day < 10 Then
  98.     Sday := '0' + Sday;
  99.   MachineDate := smonth + sday + syear;
  100. End;
  101.  
  102. Function DateFactor(MonthNum, DayNum, YearNum : Real) : Real;
  103. Var
  104.   Factor : Real;
  105. Begin
  106.   Factor := (365 * YearNum) + DayNum + (31 * (MonthNum - 1));
  107.   If MonthNum < 3 Then
  108.     Factor :=  Factor + Int((YearNum-1) / 4) -
  109.                Int(0.75 * (Int((YearNum-1) / 100) + 1))
  110.   Else
  111.     Factor :=  Factor - Int(0.4 * MonthNum + 2.3) + Int(YearNum / 4) -
  112.                Int(0.75 * (Int(YearNum / 100) + 1));
  113.   DateFactor := Factor;
  114. End;
  115.  
  116. Function DateToJulian(DateLine : Str8) : Integer;
  117. Var
  118.   Factor,
  119.   MonthNum,
  120.   DayNum,
  121.   YearNum : Real;
  122.   Ti      : Integer;
  123. Begin
  124.   If Length(DateLine) = 7 Then
  125.     DateLine := '0' + DateLine;
  126.   MonthNum := 0.0;
  127.   For Ti := 1 to 2 Do
  128.     MonthNum := (10 * MonthNum) + (Ord(DateLine[Ti])-Ord('0'));
  129.   DayNum := 0.0;
  130.   For Ti := 3 to 4 Do
  131.     DayNum := (10 * DayNum) + (Ord(DateLine[Ti])-Ord('0'));
  132.   YearNum := 0.0;
  133.   For Ti := 5 to 8 Do
  134.     YearNum := (10 * YearNum) + (Ord(DateLine[Ti])-Ord('0'));
  135.   Factor := DateFactor(MonthNum, DayNum, YearNum);
  136.   DateToJulian := Trunc((Factor - 679351.0) - 32767.0);
  137. End;
  138.  
  139. Function JulianToDate(DateInt : Integer): Str11;
  140. Var
  141.   holdstr,
  142.   strDay   : string[2];
  143.   anystr   : string[11];
  144.   StrMonth : string[3];
  145.   stryear  :  string[4];
  146.   test,
  147.   error,
  148.   Year,
  149.   Dummy, I : Integer;
  150.   Save,
  151.   Temp     : Real;
  152.   JulianToanystring : Str11;
  153. Begin
  154.   holdstr := '';
  155.   JulianToanystring := '00000000000';
  156.   Temp  := Int(DateInt) + 32767 + 679351.0;
  157.   Save  := Temp;
  158.   Dummy := Trunc(Temp/365.5);
  159.  
  160.   While Save >= DateFactor(1.0,1.0,Dummy+0.0) Do
  161.     Dummy := Succ(Dummy);
  162.   Dummy := Pred(Dummy);
  163.   Year  := Dummy;
  164.   (* Determine number Of Days into current year *)
  165.   Temp  := 1.0 + Save - DateFactor(1.0,1.0,Year+0.0);
  166.   (* Put the Year into the output string *)
  167.   For I := 8 downto 5 Do
  168.   Begin
  169.     JulianToanystring[I] := Char((Dummy mod 10) + Ord('0'));
  170.     Dummy := Dummy div 10;
  171.   End;
  172.   Dummy := 1 + Trunc(Temp/31.5);
  173.   While Save >= DateFactor(Dummy+0.0,1.0,Year+0.0) Do
  174.     Dummy := Succ(Dummy);
  175.   Dummy := Pred(Dummy);
  176.   Temp  := 1.0 + Save - DateFactor(Dummy+0.0,1.0,Year+0.0);
  177.   For I := 2 Downto 1 Do
  178.   Begin
  179.     JulianToanystring[I] := Char((Dummy mod 10)+Ord('0'));
  180.     Dummy := Dummy div 10;
  181.   End;
  182.   Dummy := Trunc(Temp);
  183.  
  184.   For I := 4 Downto 3 Do
  185.   Begin
  186.     JulianToanystring[I] := Char((Dummy mod 10)+Ord('0'));
  187.     Dummy := Dummy div 10;
  188.   End;
  189.   holdstr := copy(juliantoanystring,1,2);
  190.   val(holdstr, test, error);
  191.   Case test Of
  192.     1 : StrMonth := 'Jan';
  193.     2 : StrMonth := 'Feb';
  194.     3 : StrMonth := 'Mar';
  195.     4 : StrMonth := 'Apr';
  196.     5 : StrMonth := 'May';
  197.     6 : StrMonth := 'Jun';
  198.     7 : StrMonth := 'Jul';
  199.     8 : StrMonth := 'Aug';
  200.     9 : StrMonth := 'Sep';
  201.    10 : StrMonth := 'Oct';
  202.    11 : StrMonth := 'Nov';
  203.    12 : StrMonth := 'Dec';
  204.   End;
  205.   stryear := copy(juliantoanystring, 5, 4);
  206.   strDay  := copy(juliantoanystring, 3, 2);
  207.   anystr  := StrDay + '-' + StrMonth + '-' +stryear;
  208.   JulianToDate := anystr;
  209. End;
  210.  
  211. Function JulianToStr8(DateInt : Integer): Str8;
  212. Var
  213.   holdstr,
  214.   StrMonth,
  215.   strDay   : string[2];
  216.   anystr   : string[8];
  217.   stryear  : string[4];
  218.   test,
  219.   error,
  220.   Year,
  221.   Dummy,
  222.   I       : Integer;
  223.   Save,
  224.   Temp    : Real;
  225.   JulianToanystring : Str8;
  226. Begin
  227.   holdstr := '';
  228.   JulianToanystring := '00000000';
  229.   Temp  := Int(DateInt) + 32767 + 679351.0;
  230.   Save  := Temp;
  231.   Dummy := Trunc(Temp/365.5);
  232.   While Save >= DateFactor(1.0,1.0,Dummy+0.0) Do
  233.     Dummy := Succ(Dummy);
  234.   Dummy := Pred(Dummy);
  235.   Year  := Dummy;
  236.   (* Determine number Of Days into current year *)
  237.   Temp  := 1.0 + Save - DateFactor(1.0,1.0,Year+0.0);
  238.   (* Put the Year into the output string *)
  239.   For I := 8 downto 5 Do
  240.   Begin
  241.     JulianToanystring[I] := Char((Dummy mod 10)+Ord('0'));
  242.     Dummy := Dummy div 10;
  243.   End;
  244.   Dummy := 1 + Trunc(Temp/31.5);
  245.   While Save >= DateFactor(Dummy+0.0,1.0,Year+0.0) Do
  246.     Dummy := Succ(Dummy);
  247.   Dummy := Pred(Dummy);
  248.   Temp  := 1.0 + Save - DateFactor(Dummy+0.0,1.0,Year+0.0);
  249.   For I := 2 Downto 1 Do
  250.   Begin
  251.     JulianToanystring[I] := Char((Dummy mod 10)+Ord('0'));
  252.     Dummy := Dummy div 10;
  253.   End;
  254.   Dummy := Trunc(Temp);
  255.  
  256.   For I := 4 Downto 3 Do
  257.   Begin
  258.     JulianToanystring[I] := Char((Dummy mod 10)+Ord('0'));
  259.     Dummy := Dummy div 10;
  260.   End;
  261.  
  262.   holdstr := copy(juliantoanystring,1,2);
  263.   val(holdstr, test, error);
  264.   Case test Of
  265.     1 : StrMonth := '01';
  266.     2 : StrMonth := '02';
  267.     3 : StrMonth := '03';
  268.     4 : StrMonth := '04';
  269.     5 : StrMonth := '05';
  270.     6 : StrMonth := '06';
  271.     7 : StrMonth := '07';
  272.     8 : StrMonth := '08';
  273.     9 : StrMonth := '09';
  274.    10 : StrMonth := '10';
  275.    11 : StrMonth := '11';
  276.    12 : StrMonth := '12';
  277.   End;
  278.   StrYear := copy(juliantoanystring, 5, 4);
  279.   StrDay  := copy(juliantoanystring, 3, 2);
  280.   AnyStr  := StrMonth + StrDay + StrYear;
  281.   JulianToStr8 := AnyStr;
  282. End;
  283.  
  284. Function DayofWeek(Jdate : Integer) : Str3;
  285. Begin
  286.   Case jdate MOD 7 Of
  287.     0 : DayofWeek := 'Sun';
  288.     1 : DayofWeek := 'Mon';
  289.     2 : DayofWeek := 'Tue';
  290.     3 : DayofWeek := 'Wed';
  291.     4 : DayofWeek := 'Thu';
  292.     5 : DayofWeek := 'Fri';
  293.     6 : DayofWeek := 'Sat';
  294.   End;
  295. End;
  296.  
  297. Procedure DateDiff(Date1, Date2 : Integer; Var Date_Difference : Str9);
  298. VAR
  299.  Temp,
  300.  Rdate1,
  301.  Rdate2,
  302.  Diff1  : Real;
  303.  Diff   : Integer;
  304.  Return : String[9];
  305.  Hold   : String[3];
  306. Begin
  307.   Rdate2 := Date2 + 32767.5;
  308.   Rdate1 := Date1 + 32767.5;
  309.   Diff1  := Rdate1 - Rdate2;
  310.   Temp   := Diff1;
  311.   If Diff1 < 32 Then (* determine number of Days *)
  312.   Begin
  313.     Diff := Round(Diff1);
  314.     Str(Diff,Hold);
  315.     Return := Hold + ' ' + 'Day';
  316.     If Diff > 1 Then
  317.       Return := Return + 's  ';
  318.   End;
  319.   If ((Diff1 > 31) And (Diff1 < 366)) Then
  320.   Begin
  321.     Diff1 := Diff1 / 30;
  322.     Diff  := Round(Diff1);
  323.     Str(Diff,Hold);
  324.     Return := Hold + ' ' + 'Month';
  325.     If Diff > 1 Then
  326.       Return := Return + 's';
  327.   End;
  328.   If Diff1 > 365 Then
  329.   Begin
  330.     Diff1 := Diff1 / 365;
  331.     Diff  := Round(Diff1);
  332.  
  333.     Str(Diff,Hold);
  334.     Return := Hold;
  335.   End;
  336.   Date_Difference := Return;
  337.   Diff := Round(Diff1);
  338. End;
  339.  
  340. END.
  341.  
  342.  
  343.